PC go! 2008 April/PCgo 2008-04 (DVD).iso/interface/contents/demoversionen_3846/13664/files/Data1.cab/roundedrect.pas

Pascal/Delphi Source File | 2001-10-16 | 16.3 KB | 526 lines

unit RoundedRect;

interface

uses
  ComObj,
  ActiveX,
  RRect_TLB,
  Forms,
  PropPageF,
  Windows,
  SysUtils,
  Controls;

type
  TRoundedRect = class(TAutoObject, IRoundedRect)
  protected
  MyForm: TForm1; { Property Page form }

 // protected
    function Draw(GrfThis, View, mat: OleVariant): WordBool; safecall;
    function Get_ClassID: WideString; safecall;
    function Get_Description: WideString; safecall;
    function GetEnumNames(PropID: Integer; var Names,
      Values: OleVariant): Integer; safecall;
    function GetPageInfo(AGraphic: OleVariant; var StockPages: Integer;
      var Names: OleVariant): Integer; safecall;
    function GetPropertyInfo(var Names, Types, IDs,
      Defaults: OleVariant): Integer; safecall;
    function GetWizardInfo(var Names: OleVariant): Integer; safecall;
    function OnCopyGraphic(grfCopy, grfSource: OleVariant): WordBool;
      safecall;
    function OnGeometryChanging(Graphic: OleVariant; GeomID: Integer;
      ParamOld, ParamNew: OleVariant): WordBool; safecall;
    function OnNewGraphic(grfThis: OleVariant; boolCopy: WordBool): WordBool;
      safecall;
    function OnPropertyChanging(Graphic: OleVariant; PropID: Integer;
      ValueOld, ValueNew: OleVariant): WordBool; safecall;
    function PageControls(ThisRegenMethod, Graphic: OleVariant;
      PageNumber: Integer; SaveProperties: WordBool): WordBool; safecall;
    function PropertyPages(ThisRegenMethod, PageNumber: OleVariant): WordBool;
      safecall;
    function Wizard(ThisRegenMethod, WizardNumber: OleVariant): WordBool;
      safecall;
    procedure OnGeometryChanged(Graphic: OleVariant; GeomID: Integer;
      ParanOld, ParamNew: OleVariant); safecall;
    procedure OnPropertyChanged(Graphic: OleVariant; PropID: Integer;
      OldValue, NewValue: OleVariant); safecall;
    procedure OnPropertyGet(Graphic: OleVariant; PropID: Integer); safecall;
    procedure PageDone(ThisRegenMethod, PageNumber: OleVariant); safecall;
    procedure Regen(grfThis: OleVariant); safecall;
    { Protected declarations }
  end;
const
{ DBAPI constants }
  gkGraphic = 11;
  gkArc = 2;
  gkText = 6;
  gfCosmetic = 128;


{ Useful math constants }
  Pi: double = 3.14159265;
{ Stock property pages }
  ppStockPen = 1;
  ppStockBrush = 2;
  ppStockText = 4;
  ppStockInsert = 8;
  ppStockViewport = 16;
  ppStockAuto = 32;

{ Property Ids }
  idRoundness = 1;
{ Number of properties, pages, wizards }
  NUM_PROPERTIES = 1;
  NUM_PAGES = 1;
  NUM_WIZARDS = 0;

implementation

uses ComServ;

function TRoundedRect.Draw(GrfThis, View, mat: OleVariant): WordBool;
begin
    Result:=False;
end;

function TRoundedRect.Get_ClassID: WideString;
begin
     Result:=GUIDtoString(CLASS_RoundedRect);
end;

function TRoundedRect.Get_Description: WideString;
begin
     Result:='SDK Delphi v4 rounded rectangle';
end;

function TRoundedRect.GetEnumNames(PropID: Integer; var Names,
  Values: OleVariant): Integer;
begin
    Result := 0;
end;

function TRoundedRect.GetPageInfo(AGraphic: OleVariant;
  var StockPages: Integer; var Names: OleVariant): Integer;
begin

   VarArrayRedim(Names, NUM_PAGES);

   { Need the form }

   MyForm := TForm1.Create(Application);
   Names[0] := MyForm.Caption;
   MyForm.Free;

   StockPages := ppStockBrush + ppStockPen + ppStockAuto;
   Result := NUM_PAGES;

end;

function TRoundedRect.GetPropertyInfo(var Names, Types, IDs,
  Defaults: OleVariant): Integer;
begin
    try
      VarArrayRedim(Names, NUM_PROPERTIES);
      VarArrayRedim(Types, NUM_PROPERTIES);
      VarArrayRedim(IDs, NUM_PROPERTIES);
      VarArrayRedim(Defaults, NUM_PROPERTIES);
      Names[0] := 'Roundness';
      Types[0] := varDouble;
      IDs[0] := idRoundness;
      Defaults[0] := 50.0;

      Result := NUM_PROPERTIES;

    except
        Result := 0;
    //  GetPropertyInfo := 0;
   end;

end;

function TRoundedRect.GetWizardInfo(var Names: OleVariant): Integer;
begin
    Result := NUM_WIZARDS;
end;

function TRoundedRect.OnCopyGraphic(grfCopy,
  grfSource: OleVariant): WordBool;
begin
    Result := True;
end;

function TRoundedRect.OnGeometryChanging(Graphic: OleVariant;
  GeomID: Integer; ParamOld, ParamNew: OleVariant): WordBool;
begin
    Result := True;
end;

function TRoundedRect.OnNewGraphic(grfThis: OleVariant;
  boolCopy: WordBool): WordBool;
var
   R, Roundness, Offset: double;
   Vertices, vTrue, vFalse: OleVariant;
   X, Y, Z: double;
  begin
{  MessageBox ( NULL,'On new Graphic method','vv', IDOK);}
    if boolCopy then
    begin
        { Vertices are already added for us... }
        Result := True;
        exit;
    end;

    try
        { New Graphic being created }
        { Temporary veriable for Vertices.Add }
        Vertices := grfThis.Vertices;

        { Define True and False variants }
        vTrue := True;
        vFalse := False;

        { First Vertex is "lower left" corner }
        { Arguments for Vertices.Add are:
        { X, Y, Z: double; }
        { PenDown, Selectable, Snappable, Editable, Linkable, Calculated, }
        { Before, After: OleVariant. }
        { Specify all flags;  Omit Before and After arguments. }
        X := -1.0;
        Y := -0.5;
        Z := 0.0;
        Vertices.Add(X, Y, Z,
            vFalse, vTrue, vFalse, vFalse, vFalse, vFalse, , );

        { Second Vertex is "upper right" corner }
        X := 1.0;
        Y := 0.5;
        Vertices.Add(X, Y, Z,
            vFalse, vTrue, vFalse, vFalse, vFalse, vFalse, , );

        { Third Vertex is rounding handle (calculated) }
        Roundness := grfThis.Properties['Roundness'];
        R := 0.5 * Roundness / 100.0;
        Offset := 0.1 * R;
        X := 1.0 - R;
        Y := 0.5 + Offset;
           Vertices.Add(X, Y, Z,
            vFalse, vFalse, vFalse, vFalse, vFalse, vFalse, , );

        { Fourth Vertex is rounding handle (editable) }
           Vertices.Add(X, Y, Z,
            vFalse, vTrue, vFalse, vTrue, vFalse, vFalse, , );
        OnNewGraphic := True;
 //       Result := True;
    except
    { Return false on failure }
       Result := False;
    end;

end;

function TRoundedRect.OnPropertyChanging(Graphic: OleVariant;
  PropID: Integer; ValueOld, ValueNew: OleVariant): WordBool;
begin
    Result:=True;
end;

function TRoundedRect.PageControls(ThisRegenMethod, Graphic: OleVariant;
  PageNumber: Integer; SaveProperties: WordBool): WordBool;

var
   Roundness: double;
begin
     try
        if SaveProperties then
        begin
            { OK button on property page was clicked }
            { Form is still loaded }
            with MyForm do
            begin
                { Need try block for the case where you have }
                { TRoundedRect Turbo Shape and ahother "shape" selected }
                try
                   { When the property page is closed, transfer the numeric }
                   { roundness value from the EditBox to the Graphic }
                   { Get the value as a double-precision number }
                   Roundness := StrToFloat(txtRoundness.Text);

                   { Make sure it's between 0 and 100 }
                   if Roundness < 0.0 then Roundness := 0.0;
                   if Roundness > 100.0 then Roundness := 100.0;
                   { Set the roundness property value in the Graphic }
                   Graphic.Properties['Roundness'] := Roundness;
                except
                end;
            end;
        end
        else
        begin
            { Property page is about to be opened }
            { Make sure the form is loaded }
            MyForm := TForm1.Create(Application);
            with MyForm do
            begin
                { If more than one TRoundedRect is selected and they do not }
                { have the same properties, don't set up this field }
                try

                    { When the property page is opening, transfer the numeric }
                    { roundness value from the Graphic to the TextBox }
                    { Get the roundness property value from the Graphic }
                    Roundness := Graphic.Properties['Roundness'];
                    { Set the EditBox control's text }
                        txtRoundness.Text := FloatToStrF(Roundness, ffGeneral,
                                   3, 0);
                except
                end;
            end;
        end;
        Result:=True;

     except
        { For debugging purposes, report that an error occurred }
        { Return false if an error occurred }
         Result := False;

     end;
end;

function TRoundedRect.PropertyPages(ThisRegenMethod,
  PageNumber: OleVariant): WordBool;
var
   PageResult: Integer;
begin
    with MyForm do
    begin
        PageResult := ShowModal;
        Result := (PageResult = mrOk);
    end;
end;

function TRoundedRect.Wizard(ThisRegenMethod,
  WizardNumber: OleVariant): WordBool;
begin
     Result := False;
end;

procedure TRoundedRect.OnGeometryChanged(Graphic: OleVariant;
  GeomID: Integer; ParanOld, ParamNew: OleVariant);
begin

end;

procedure TRoundedRect.OnPropertyChanged(Graphic: OleVariant;
  PropID: Integer; OldValue, NewValue: OleVariant);
begin

end;

procedure TRoundedRect.OnPropertyGet(Graphic: OleVariant;
  PropID: Integer);
begin

end;

procedure TRoundedRect.PageDone(ThisRegenMethod, PageNumber: OleVariant);
begin
        MyForm.Free;
end;

procedure TRoundedRect.Regen(grfThis: OleVariant);
var
    LockCount: Integer;
    boolHandleMoved: WordBool;
    W, H, R, Roundness: double;
    X, Y, Z, X0, Y0, X1, Y1, T, StartAngle, EndAngle: double;
        Props, propRoundness: OleVariant;
        grfChild, Vertices, V0, V1, V2, V3, vTrue, vFalse: OleVariant;
begin
  //MessageBox ( NULL,'On Regen method','vv', IDOK);
  { Setup error handler }
  try
     { grfThis.Application.PushVertexDefaults Editable:=True, Selectable:=True }

     { Set up lock (prevent recursion) }
     LockCount := grfThis.RegenLock;

     { Setup error handler (make sure lock is removed) }
     if LockCount = 0 then
     begin
         try
            { Delete any previous cosmetic children }
            grfThis.Graphics.Clear(gfCosmetic);

            { Calculate height, width and radius of corners }
            Vertices := grfThis.Vertices;
            V0 := Vertices.Item[0]; { First corner }
            V1 := Vertices.Item[1]; { Diagonal corner }
            V2 := Vertices.Item[2]; { Radius }
            V3 := Vertices.Item[3]; { Drag handle }

            if (Abs(V2.X - V3.X) < 0.000001) and
               (Abs(V2.Y - V3.Y) < 0.000001) then boolHandleMoved := False
            else boolHandleMoved := True;

            W := Abs(V1.X - V0.X);
            H := Abs(V1.Y - V0.Y);

            { Radius of arcs is based on minimum of width and height }
            if W < H then R := W / 2.0
            else R := H / 2.0;

            { Adjust radius for roundness }
            Props := grfThis.Properties;
            propRoundness := Props.Item['Roundness'];
            if boolHandleMoved then
            begin
                Roundness := Abs(V2.X - V3.X);
                Roundness := Roundness * 100.0 / R;
                if Roundness > 100.0 then Roundness := 100.0;
                { Relocate handle }

                { Update property to reflect handle location }
                propRoundness.Value := Roundness;
            end
            else
            begin
                Roundness := propRoundness.Value;
                if Roundness < 0.0 then Roundness := 0.0;
                if Roundness > 100.0 then Roundness := 100.0;
            end;
            R := R * Roundness / 100.0;

            { Add child Graphics }
            X0 := V0.X;
            Y0 := V0.Y;
            X1 := V1.X;
            Y1 := V1.Y;
            { Make sure X0 < X1 }
            if X0 > X1 then
            begin
                T := X0;
                X0 := X1;
                X1 := T;
            end;
            { Make sure Y0 < Y1 }
            if Y0 > Y1 then
            begin
                T := Y0;
                Y0 := Y1;
                Y1 := T;
            end;

            vTrue := True;
            vFalse := False;
            if R = 0 then
            begin
                { No rounded corners }
                { All children are cosmetic }
                grfChild := grfThis.Graphics.Add( , , vTrue, , , );
                grfChild.Cosmetic := True;
                { Now add vertices to the child }
                Vertices := grfChild.Vertices;
                X := X0;
                Y := Y0;
                Z := 0.0;
                Vertices.Add(X, Y, Z, , , , , , , , );
                Y := Y1;
                Vertices.Add(X, Y, Z, vTrue, , , , , , , );
                X := X1;
                Vertices.Add(X, Y, Z, vTrue, , , , , , , );
                Y := Y0;
                Vertices.Add(X, Y, Z, vTrue, , , , , , , );
                { Close the rectangle }
                Vertices.AddClose(vTrue, , , , , );
            end
            else
            begin
                { Rounded corners }
                { We'll make 4 line children and 4 arc children }
                { First line }
                { All children are cosmetic }
                grfChild := grfThis.Graphics.Add( , , vTrue, , , );
                grfChild.Cosmetic := True;
                { Now add vertices to the child }
                Vertices := grfChild.Vertices;
                X := X0 + R;
                Y := Y0;
                Z := 0;
                Vertices.Add(X, Y, Z, , , , , , , , );
                X := X1 - R;
                Vertices.Add(X, Y, Z, vTrue, , , , , , , );
                { First arc }
                grfChild := grfThis.Graphics.Add(gkArc, , vTrue, , , );
                grfChild.Cosmetic := True;
                Y := Y0 + R;
                StartAngle := 1.5 * Pi;
                EndAngle := 0.0;
                grfChild.ArcSet(X, Y, Z, R, , StartAngle, EndAngle, );
                { Second line }
                grfChild := grfThis.Graphics.Add( , , vTrue, , , );
                grfChild.Cosmetic := True;
                Vertices := grfChild.Vertices;
                X := X1;
                Vertices.Add(X, Y, Z, , , , , , , , );
                Y := Y1 - R;
                Vertices.Add(X, Y, Z, vTrue, , , , , , , );
                { Second arc }
                grfChild := grfThis.Graphics.Add(gkArc, , vTrue, , , );
                grfChild.Cosmetic := True;
                X := X1 - R;
                StartAngle := 0.0;
                EndAngle := 0.5 * Pi;
                grfChild.ArcSet(X, Y, Z, R, , StartAngle, EndAngle, );
                { Third line }
                grfChild := grfThis.Graphics.Add( , , vTrue, , , );
                grfChild.Cosmetic := True;
                Vertices := grfChild.Vertices;
                Y := Y1;
                Vertices.Add(X, Y, Z, , , , , , , , );
                X := X0 + R;
                Vertices.Add(X, Y, Z, vTrue, , , , , , , );
                { Third arc }
                grfChild := grfThis.Graphics.Add(gkArc, , vTrue, , , );
                grfChild.Cosmetic := True;
                Y := Y1 - R;
                StartAngle := 0.5 * Pi;
                EndAngle := Pi;
                grfChild.ArcSet(X, Y, Z, R, , StartAngle, EndAngle, );
                { Fourth line }
                grfChild := grfThis.Graphics.Add( , , vTrue, , , );
                grfChild.Cosmetic := True;
                Vertices := grfChild.Vertices;
                X := X0;
                Vertices.Add(X, Y, Z, , , , , , , , );
                Y := Y0 + R;
                Vertices.Add(X, Y, Z, vTrue, , , , , , , );
                { Fourth arc }
                grfChild := grfThis.Graphics.Add(gkArc, , vTrue, , , );
                grfChild.Cosmetic := True;
                X := X0 + R;
                StartAngle := Pi;
                EndAngle := 1.5 * Pi;
                grfChild.ArcSet(X, Y, Z, R, , StartAngle, EndAngle, );
            end;

            { Add visible child Graphics }

         except
         end;
     end; { if LockCount = 0 }

     { Remove lock }
     grfThis.RegenUnlock;
     { grfThis.Application.PopVertexDefaults }
  except
  end;

end;

initialization
  TAutoObjectFactory.Create(ComServer, TRoundedRect, Class_RoundedRect,
    ciMultiInstance, tmApartment);
end.